home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / BITSTR.C < prev    next >
C/C++ Source or Header  |  1991-10-29  |  28KB  |  937 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/users/jinx/microcode/RCS/bitstr.c,v 9.49 1991/10/29 22:55:11 jinx Exp $
  4.  
  5. Copyright (c) 1987-91 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Bit string primitives.
  36.    Conversions between nonnegative integers and bit strings are
  37.    implemented here; they use the standard binary encoding, in which
  38.    each index selects the bit corresponding to that power of 2.  Thus
  39.    bit 0 is the LSB. */
  40.  
  41. #include "scheme.h"
  42. #include "prims.h"
  43. #include "bitstr.h"
  44.  
  45. SCHEME_OBJECT
  46. DEFUN (allocate_bit_string, (length), long length)
  47. {
  48.   long total_pointers;
  49.   SCHEME_OBJECT result;
  50.  
  51.   total_pointers = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (length)));
  52.   result = (allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true));
  53.   FAST_MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length);
  54.   return (result);
  55. }
  56.  
  57. /* (BIT-STRING-ALLOCATE length)
  58.    Returns an uninitialized bit string of the given length. */
  59.  
  60. DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0)
  61. {
  62.   PRIMITIVE_HEADER (1);
  63.   PRIMITIVE_RETURN (allocate_bit_string (arg_nonnegative_integer (1)));
  64. }
  65.  
  66. /* (BIT-STRING? object)
  67.    Returns #T iff object is a bit string. */
  68.  
  69. DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1, 1, 0)
  70. {
  71.   fast SCHEME_OBJECT object;
  72.   PRIMITIVE_HEADER (1);
  73.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  74.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (object)));
  75. }
  76.  
  77. void
  78. DEFUN (fill_bit_string, (bit_string, sense),
  79.        SCHEME_OBJECT bit_string AND Boolean sense)
  80. {
  81.   SCHEME_OBJECT *scanner;
  82.   SCHEME_OBJECT filler;
  83.   long i;
  84.  
  85.   filler = ((SCHEME_OBJECT) (sense ? (~ 0) : 0));
  86.   scanner = BIT_STRING_HIGH_PTR (bit_string);
  87.   for (i = BIT_STRING_LENGTH_TO_GC_LENGTH (BIT_STRING_LENGTH (bit_string));
  88.        (i > 0); i -= 1)
  89.     (* (DEC_BIT_STRING_PTR (scanner))) = filler;
  90. }
  91.  
  92. void
  93. DEFUN (clear_bit_string, (bit_string), SCHEME_OBJECT bit_string)
  94. {
  95.   SCHEME_OBJECT *scanner;
  96.   long i;
  97.  
  98.   scanner = BIT_STRING_HIGH_PTR (bit_string);
  99.   for (i = BIT_STRING_LENGTH_TO_GC_LENGTH (BIT_STRING_LENGTH (bit_string));
  100.        (i > 0); i -= 1)
  101.     (* (DEC_BIT_STRING_PTR (scanner))) = 0;
  102. }
  103.  
  104. /* (MAKE-BIT-STRING size initialization)
  105.    Returns a bit string of the specified size with all the bits
  106.    set to zero if the initialization is false, one otherwise. */
  107.  
  108. DEFINE_PRIMITIVE ("MAKE-BIT-STRING", Prim_make_bit_string, 2, 2, 0)
  109. {
  110.   SCHEME_OBJECT result;
  111.   PRIMITIVE_HEADER (2);
  112.   result = allocate_bit_string (arg_nonnegative_integer (1));
  113.   fill_bit_string (result, (OBJECT_TO_BOOLEAN (ARG_REF (2))));
  114.   PRIMITIVE_RETURN (result);
  115. }
  116.  
  117. /* (BIT-STRING-FILL! bit-string initialization)
  118.    Fills the bit string with zeros if the initialization is false,
  119.    otherwise fills it with ones. */
  120.  
  121. DEFINE_PRIMITIVE ("BIT-STRING-FILL!", Prim_bit_string_fill_x, 2, 2, 0)
  122. {
  123.   PRIMITIVE_HEADER (2);
  124.   CHECK_ARG (1, BIT_STRING_P);
  125.   fill_bit_string ((ARG_REF (1)), (OBJECT_TO_BOOLEAN (ARG_REF (2))));
  126.   PRIMITIVE_RETURN (UNSPECIFIC);
  127. }
  128.  
  129. /* (BIT-STRING-LENGTH bit-string)
  130.    Returns the number of bits in BIT-STRING. */
  131.  
  132. DEFINE_PRIMITIVE ("BIT-STRING-LENGTH", Prim_bit_string_length, 1, 1, 0)
  133. {
  134.   PRIMITIVE_HEADER (1);
  135.   CHECK_ARG (1, BIT_STRING_P);
  136.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (BIT_STRING_LENGTH (ARG_REF (1))));
  137. }
  138.  
  139. #define REF_INITIALIZATION()                        \
  140.   fast SCHEME_OBJECT bit_string;                    \
  141.   fast long index;                            \
  142.   fast SCHEME_OBJECT *ptr;                        \
  143.   fast long mask;                            \
  144.   PRIMITIVE_HEADER (2);                            \
  145.                                     \
  146.   CHECK_ARG (1, BIT_STRING_P);                        \
  147.   bit_string = (ARG_REF (1));                        \
  148.   index = (arg_nonnegative_integer (2));                \
  149.   if (index >= (BIT_STRING_LENGTH (bit_string)))            \
  150.     error_bad_range_arg (2);                        \
  151.                                     \
  152.   ptr =                                    \
  153.     (MEMORY_LOC                                \
  154.      (bit_string, (BIT_STRING_INDEX_TO_WORD (bit_string, index))));    \
  155.   mask = (1 << (index % OBJECT_LENGTH))
  156.  
  157. /* (BIT-STRING-REF bit-string index)
  158.    Returns the boolean value of the indexed bit. */
  159.  
  160. DEFINE_PRIMITIVE ("BIT-STRING-REF", Prim_bit_string_ref, 2, 2, 0)
  161. {
  162.   REF_INITIALIZATION ();
  163.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (((BIT_STRING_WORD (ptr)) & mask) != 0));
  164. }
  165.  
  166. /* (BIT-STRING-CLEAR! bit-string index)
  167.    Sets the indexed bit to zero, returning its previous value
  168.    as a boolean. */
  169.  
  170. DEFINE_PRIMITIVE ("BIT-STRING-CLEAR!", Prim_bit_string_clear_x, 2, 2, 0)
  171. {
  172.   REF_INITIALIZATION ();
  173.   if (((BIT_STRING_WORD (ptr)) & mask) == 0)
  174.     PRIMITIVE_RETURN (SHARP_F);
  175.   (BIT_STRING_WORD (ptr)) &= ~mask;
  176.   PRIMITIVE_RETURN (SHARP_T);
  177. }
  178.  
  179. /* (BIT-STRING-SET! bit-string index)
  180.    Sets the indexed bit to one, returning its previous value
  181.    as a boolean. */
  182.  
  183. DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2, 0)
  184. {
  185.   REF_INITIALIZATION ();
  186.   if (((BIT_STRING_WORD (ptr)) & mask) != 0)
  187.     PRIMITIVE_RETURN (SHARP_T);
  188.   ((BIT_STRING_WORD (ptr))) |= mask;
  189.   PRIMITIVE_RETURN (SHARP_F);
  190. }
  191.  
  192. #define ZERO_SECTION_P()                        \
  193. {                                    \
  194.   for (i = (length / OBJECT_LENGTH); (i > 0); i -= 1)            \
  195.     if ((* (DEC_BIT_STRING_PTR (scan))) != 0)                \
  196.       PRIMITIVE_RETURN (SHARP_F);                    \
  197.   PRIMITIVE_RETURN (SHARP_T);                        \
  198. }
  199.  
  200. /* (BIT-STRING-ZERO? bit-string)
  201.    Returns true the argument has no "set" bits. */
  202.  
  203. DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1, 1, 0)
  204. {
  205.   fast SCHEME_OBJECT bit_string;
  206.   fast SCHEME_OBJECT *scan;
  207.   fast long i;
  208.   long length, odd_bits;
  209.   PRIMITIVE_HEADER (1);
  210.   CHECK_ARG (1, BIT_STRING_P);
  211.   bit_string = (ARG_REF (1));
  212.   length = (BIT_STRING_LENGTH (bit_string));
  213.   odd_bits = (length % OBJECT_LENGTH);
  214.   scan = (BIT_STRING_HIGH_PTR (bit_string));
  215.   if (odd_bits == 0)
  216.     {
  217.       ZERO_SECTION_P ();
  218.     }
  219.   else if (((BIT_STRING_WORD (scan)) & (LOW_MASK (odd_bits))) != 0)
  220.     PRIMITIVE_RETURN (SHARP_F);
  221.   else
  222.     {
  223.       DEC_BIT_STRING_PTR (scan);
  224.       ZERO_SECTION_P ();
  225.     }
  226. }
  227.  
  228. #define EQUAL_SECTIONS_P()                        \
  229. {                                    \
  230.   for (i = (length / OBJECT_LENGTH); (i > 0); i -= 1)            \
  231.     if ((* (DEC_BIT_STRING_PTR (scan1))) !=                \
  232.     (* (DEC_BIT_STRING_PTR (scan2))))                \
  233.       PRIMITIVE_RETURN (SHARP_F);                    \
  234.   PRIMITIVE_RETURN (SHARP_T);                        \
  235. }
  236.  
  237. /* (BIT-STRING=? bit-string-1 bit-string-2)
  238.    Returns true iff the two bit strings contain the same bits. */
  239.  
  240. DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2, 0)
  241. {
  242.   SCHEME_OBJECT bit_string_1, bit_string_2;
  243.   long length;
  244.   fast SCHEME_OBJECT *scan1, *scan2;
  245.   fast long i;
  246.   long odd_bits;
  247.   PRIMITIVE_HEADER (2);
  248.   CHECK_ARG (1, BIT_STRING_P);
  249.   CHECK_ARG (2, BIT_STRING_P);
  250.   bit_string_1 = (ARG_REF (1));
  251.   bit_string_2 = (ARG_REF (2));
  252.   length = BIT_STRING_LENGTH (bit_string_1);
  253.   if (length != BIT_STRING_LENGTH (bit_string_2))
  254.     PRIMITIVE_RETURN (SHARP_F);
  255.   scan1 = (BIT_STRING_HIGH_PTR (bit_string_1));
  256.   scan2 = (BIT_STRING_HIGH_PTR (bit_string_2));
  257.   odd_bits = (length % OBJECT_LENGTH);
  258.   if (odd_bits == 0)
  259.     {
  260.       EQUAL_SECTIONS_P ();
  261.     }
  262.   else
  263.     {
  264.       long mask;
  265.  
  266.       mask = (LOW_MASK (odd_bits));
  267.       if (((BIT_STRING_MSW (bit_string_1)) & mask) !=
  268.       ((BIT_STRING_MSW (bit_string_2)) & mask))
  269.     PRIMITIVE_RETURN (SHARP_F);
  270.       else
  271.     {
  272.       DEC_BIT_STRING_PTR (scan1);
  273.       DEC_BIT_STRING_PTR (scan2);
  274.       EQUAL_SECTIONS_P ();
  275.     }
  276.     }
  277. }
  278.  
  279. /* (BIT-STRING-OPERATION! destination source)
  280.    Modifies destination to be the result of using OPERATION bitwise on
  281.    destination and source. */
  282.  
  283. #define BITWISE_OP(action)                        \
  284. {                                    \
  285.   SCHEME_OBJECT bit_string_1, bit_string_2;                \
  286.   fast long i;                                \
  287.   fast SCHEME_OBJECT *scan1, *scan2;                    \
  288.   PRIMITIVE_HEADER (2);                            \
  289.   bit_string_1 = (ARG_REF (1));                        \
  290.   bit_string_2 = (ARG_REF (2));                        \
  291.   if ((BIT_STRING_LENGTH (bit_string_1)) !=                \
  292.       (BIT_STRING_LENGTH (bit_string_2)))                \
  293.     error_bad_range_arg (1);                        \
  294.   scan1 = (BIT_STRING_HIGH_PTR (bit_string_1));                \
  295.   scan2 = (BIT_STRING_HIGH_PTR (bit_string_2));                \
  296.   for (i = ((VECTOR_LENGTH (bit_string_1)) - 1); (i > 0); i -= 1)    \
  297.     (* (DEC_BIT_STRING_PTR (scan1))) action                \
  298.       (* (DEC_BIT_STRING_PTR (scan2)));                    \
  299.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  300. }
  301.  
  302. DEFINE_PRIMITIVE ("BIT-STRING-MOVE!", Prim_bit_string_move_x, 2, 2, 0)
  303.      BITWISE_OP (=)
  304.  
  305. DEFINE_PRIMITIVE ("BIT-STRING-MOVEC!", Prim_bit_string_movec_x, 2, 2, 0)
  306.      BITWISE_OP (=~)
  307.  
  308. DEFINE_PRIMITIVE ("BIT-STRING-OR!", Prim_bit_string_or_x, 2, 2, 0)
  309.      BITWISE_OP (|=)
  310.  
  311. DEFINE_PRIMITIVE ("BIT-STRING-AND!", Prim_bit_string_and_x, 2, 2, 0)
  312.      BITWISE_OP (&=)
  313.  
  314. DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2, 2, 0)
  315.      BITWISE_OP (&=~)
  316.  
  317. DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2, 2, 0)
  318.      BITWISE_OP (^=)
  319.  
  320. /* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
  321.    Destructively copies the substring of SOURCE between START1 and
  322.    END1 into DESTINATION at START2.  The copying is done from the
  323.    MSB to the LSB (which only matters when SOURCE and DESTINATION
  324.    are the same). */
  325.  
  326. DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5, 0)
  327. {
  328.   fast SCHEME_OBJECT bit_string_1, bit_string_2;
  329.   long start1, end1, start2, end2, nbits;
  330.   long end1_mod, end2_mod;
  331.   void copy_bits();
  332.   PRIMITIVE_HEADER (5);
  333.   CHECK_ARG (1, BIT_STRING_P);
  334.   bit_string_1 = (ARG_REF (1));
  335.   start1 = (arg_nonnegative_integer (2));
  336.   end1 = (arg_nonnegative_integer (3));
  337.   CHECK_ARG (4, BIT_STRING_P);
  338.   bit_string_2 = (ARG_REF (4));
  339.   start2 = (arg_nonnegative_integer (5));
  340.   nbits = (end1 - start1);
  341.   end2 = (start2 + nbits);
  342.   if ((start1 < 0) || (start1 > end1))
  343.     error_bad_range_arg (2);
  344.   if (end1 > (BIT_STRING_LENGTH (bit_string_1)))
  345.     error_bad_range_arg (3);
  346.   if ((start2 < 0) || (end2 > (BIT_STRING_LENGTH (bit_string_2))))
  347.     error_bad_range_arg (5);
  348.   end1_mod = (end1 % OBJECT_LENGTH);
  349.   end2_mod = (end2 % OBJECT_LENGTH);
  350.   /* Using `BIT_STRING_INDEX_TO_WORD' here with -1 offset will work in every
  351.      case except when the `end' is 0.  In this case the result of
  352.      the expression `(-1 / OBJECT_LENGTH)' is either 0 or -1, at
  353.      the discretion of the C compiler being used.  This doesn't
  354.      matter because if `end' is zero, then no bits will be moved. */
  355.   copy_bits ((MEMORY_LOC
  356.           (bit_string_1,
  357.            (BIT_STRING_INDEX_TO_WORD (bit_string_1, (end1 - 1))))),
  358.         ((end1_mod == 0) ? 0 : (OBJECT_LENGTH - end1_mod)),
  359.         (MEMORY_LOC
  360.          (bit_string_2,
  361.           (BIT_STRING_INDEX_TO_WORD (bit_string_2, (end2 - 1))))),
  362.         ((end2_mod == 0) ? 0 : (OBJECT_LENGTH - end2_mod)),
  363.         nbits);
  364.   PRIMITIVE_RETURN (UNSPECIFIC);
  365. }
  366.  
  367. #define MASKED_TRANSFER(source, destination, nbits, offset) do        \
  368. {                                    \
  369.   long mask;                                \
  370.                                     \
  371.   mask = (ANY_MASK (nbits, offset));                    \
  372.   (BIT_STRING_WORD (destination)) =                    \
  373.     (((BIT_STRING_WORD (source)) & mask) |                \
  374.      ((BIT_STRING_WORD (destination)) & ~mask));            \
  375. } while (0)
  376.  
  377. /* This procedure copies bits from one place to another.
  378.    The offsets are measured from the MSB of the first SCHEME_OBJECT of
  379.    each of the arguments SOURCE and DESTINATION.  It copies the bits
  380.    starting with the MSB of a bit string and moving down. */
  381.  
  382. void
  383. DEFUN (copy_bits,
  384.        (source, source_offset, destination, destination_offset, nbits),
  385.        SCHEME_OBJECT * source AND long source_offset
  386.        AND SCHEME_OBJECT * destination AND long destination_offset
  387.        AND long nbits)
  388. {
  389.  
  390.   /* This common case can be done very quickly, by splitting the
  391.      bit string into three parts.  Since the source and destination are
  392.      aligned relative to one another, the main body of bits can be
  393.      transferred as SCHEME_OBJECTs, and only the `head' and `tail' need be
  394.      treated specially. */
  395.  
  396.   if (nbits == 0)
  397.     return;
  398.  
  399.   if (source_offset == destination_offset)
  400.     {
  401.       if (source_offset != 0)
  402.     {
  403.       long head;
  404.  
  405.       head = (OBJECT_LENGTH - source_offset);
  406.       if (nbits <= head)
  407.         {
  408.           MASKED_TRANSFER (source, destination, nbits, (head - nbits));
  409.           nbits = 0;
  410.         }
  411.       else
  412.         {
  413.           SCHEME_OBJECT temp;
  414.           long mask;
  415.  
  416.           mask = (LOW_MASK (head));
  417.           temp = (BIT_STRING_WORD (destination));
  418.           (* (DEC_BIT_STRING_PTR (destination))) =
  419.         (((* (DEC_BIT_STRING_PTR (source))) & mask) |
  420.          (temp & (~ mask)));
  421.           nbits -= head;
  422.         }
  423.     }
  424.       if (nbits > 0)
  425.     {
  426.       long nwords, tail;
  427.  
  428.       for (nwords = (nbits / OBJECT_LENGTH); (nwords > 0); nwords -= 1)
  429.         (* (DEC_BIT_STRING_PTR (destination))) =
  430.           (* (DEC_BIT_STRING_PTR (source)));
  431.  
  432.       tail = (nbits % OBJECT_LENGTH);
  433.       if (tail > 0)
  434.         MASKED_TRANSFER
  435.           (source, destination, tail, (OBJECT_LENGTH - tail));
  436.     }
  437.     }
  438.  
  439.   else if (source_offset < destination_offset)
  440.     {
  441.       long offset1, offset2, head;
  442.  
  443.       offset1 = (destination_offset - source_offset);
  444.       offset2 = (OBJECT_LENGTH - offset1);
  445.       head = (OBJECT_LENGTH - destination_offset);
  446.  
  447.       if (nbits <= head)
  448.     {
  449.       long mask;
  450.  
  451.       mask = (ANY_MASK (nbits, (head - nbits)));
  452.       (BIT_STRING_WORD (destination)) =
  453.         ((((BIT_STRING_WORD (source)) >> offset1) & mask) |
  454.          ((BIT_STRING_WORD (destination)) & ~mask));
  455.     }
  456.       else
  457.     {
  458.       long mask1, mask2;
  459.  
  460.       { SCHEME_OBJECT temp;
  461.         long mask;
  462.  
  463.         mask = (LOW_MASK (head));
  464.         temp = (BIT_STRING_WORD (destination));
  465.         (* (DEC_BIT_STRING_PTR (destination))) =
  466.           ((((BIT_STRING_WORD (source)) >> offset1) & mask) |
  467.            (temp & ~mask));
  468.       }
  469.  
  470.       nbits -= head;
  471.       mask1 = (LOW_MASK (offset1));
  472.       mask2 = (LOW_MASK (offset2));
  473.  
  474.       {
  475.         long nwords, i;
  476.  
  477.         for (nwords = (nbits / OBJECT_LENGTH); (nwords > 0); nwords -= 1)
  478.           {
  479.         i = (((* (DEC_BIT_STRING_PTR (source))) & mask1) << offset2);
  480.         (* (DEC_BIT_STRING_PTR (destination))) =
  481.           ((((BIT_STRING_WORD (source)) >> offset1) & mask2) | i);
  482.           }
  483.       }
  484.  
  485.       {
  486.         long tail, dest_tail;
  487.  
  488.         tail = (nbits % OBJECT_LENGTH);
  489.         dest_tail =
  490.           ((BIT_STRING_WORD (destination)) &
  491.            (LOW_MASK (OBJECT_LENGTH - tail)));
  492.         if (tail <= offset1)
  493.           {
  494.         (BIT_STRING_WORD (destination)) =
  495.           ((((BIT_STRING_WORD (source)) &
  496.              (ANY_MASK (tail, (offset1 - tail))))
  497.             << offset2)
  498.            | dest_tail);
  499.           }
  500.         else
  501.           {
  502.         long i, j;
  503.  
  504.         i = (((* (DEC_BIT_STRING_PTR (source))) & mask1) << offset2);
  505.         j = (tail - offset1);
  506.         (BIT_STRING_WORD (destination)) =
  507.           ((((BIT_STRING_WORD (source)) &
  508.              (ANY_MASK (j, (OBJECT_LENGTH - j))))
  509.             >> offset1)
  510.            | i | dest_tail);
  511.           }
  512.       }
  513.     }
  514.     }
  515.  
  516.   else                /* if (source_offset > destination_offset) */
  517.     {
  518.       long offset1, offset2, head;
  519.  
  520.       offset1 = (source_offset - destination_offset);
  521.       offset2 = (OBJECT_LENGTH - offset1);
  522.       head = (OBJECT_LENGTH - source_offset);
  523.  
  524.       if (nbits <= head)
  525.     {
  526.       long mask;
  527.  
  528.       mask = (ANY_MASK (nbits, (offset1 + (head - nbits))));
  529.       (BIT_STRING_WORD (destination)) =
  530.         ((((BIT_STRING_WORD (source)) << offset1) & mask) |
  531.          ((BIT_STRING_WORD (destination)) & ~mask));
  532.     }
  533.       else
  534.     {
  535.       long dest_buffer, mask1, mask2;
  536.  
  537.       {
  538.         long mask;
  539.  
  540.         mask = (ANY_MASK (head, offset1));
  541.         dest_buffer =
  542.           (((BIT_STRING_WORD (destination)) & ~mask)
  543.            | (((* (DEC_BIT_STRING_PTR (source))) << offset1) & mask));
  544.       }
  545.       nbits -= head;
  546.       mask1 = (LOW_MASK (offset1));
  547.       mask2 = (ANY_MASK (offset2, offset1));
  548.       {
  549.         long nwords;
  550.  
  551.         nwords = (nbits / OBJECT_LENGTH);
  552.         if (nwords > 0)
  553.           dest_buffer &= mask2;
  554.         for (; (nwords > 0); nwords -= 1)
  555.           {
  556.         (* (DEC_BIT_STRING_PTR (destination))) =
  557.           (dest_buffer |
  558.            (((BIT_STRING_WORD (source)) >> offset2) & mask1));
  559.         dest_buffer = ((* (DEC_BIT_STRING_PTR (source))) << offset1);
  560.           }
  561.       }
  562.  
  563.       {
  564.         long tail;
  565.  
  566.         tail = (nbits % OBJECT_LENGTH);
  567.         if (tail <= offset1)
  568.           {
  569.         long mask;
  570.  
  571.         mask = (ANY_MASK (tail, (offset1 - tail)));
  572.  
  573.  
  574.         /* This path through copy bits didn't work in certain
  575.            cases.  The line below seems to fix it.  This was an
  576.            empirical test, and I don't understand it enough to
  577.            tell if it is correct, but I think it is, and I did
  578.            a few tests.  This is probably what is broken if you
  579.            are here poking around trying to fix something.
  580.            ~JRM
  581.          */
  582.         dest_buffer &= (~ mask);
  583.  
  584.         (BIT_STRING_WORD (destination)) =
  585.           (dest_buffer |
  586.            ((BIT_STRING_WORD (destination)) &
  587.             (LOW_MASK (offset1 - tail))) |
  588.            (((BIT_STRING_WORD (source)) >> offset2) &
  589.             mask));
  590.           }
  591.         else
  592.           {
  593.         long mask;
  594.  
  595.         (* (DEC_BIT_STRING_PTR (destination))) =
  596.           (dest_buffer |
  597.            (((BIT_STRING_WORD (source)) >> offset2) & mask1));
  598.         mask = (LOW_MASK (OBJECT_LENGTH - tail));
  599.         (BIT_STRING_WORD (destination)) =
  600.           (((BIT_STRING_WORD (destination)) & (~ mask)) |
  601.            (((BIT_STRING_WORD (source)) << offset1) & mask));
  602.           }
  603.       }
  604.     }
  605.     }
  606. }
  607.  
  608. /* Integer <-> Bit-string Conversions */
  609.  
  610. long
  611. DEFUN (count_significant_bits, (number, start), long number AND long start)
  612. {
  613.   long significant_bits, i;
  614.  
  615.   significant_bits = start;
  616.   for (i = (1 << (start - 1)); (i >= 0); i >>= 1)
  617.     {
  618.       if (number >= i)
  619.     break;
  620.       significant_bits -= 1;
  621.     }
  622.   return (significant_bits);
  623. }
  624.  
  625. long
  626. DEFUN (long_significant_bits, (number), long number)
  627. {
  628.   return
  629.     ((number < 0)
  630.      ? ((sizeof (long)) * CHAR_BIT)
  631.      : (count_significant_bits (number, (((sizeof (long)) * CHAR_BIT) - 1))));
  632. }
  633.  
  634. SCHEME_OBJECT
  635. DEFUN (zero_to_bit_string, (length), long length)
  636. {
  637.   SCHEME_OBJECT result;
  638.  
  639.   result = (allocate_bit_string (length));
  640.   clear_bit_string (result);
  641.   return (result);
  642. }
  643.  
  644. SCHEME_OBJECT
  645. DEFUN (long_to_bit_string, (length, number), long length AND long number)
  646. {
  647.   if (number < 0)
  648.     error_bad_range_arg (2);
  649.  
  650.   if (number == 0)
  651.     {
  652.       return (zero_to_bit_string (length));
  653.     }
  654.   else
  655.     {
  656.       SCHEME_OBJECT result;
  657.  
  658.       if (length < (long_significant_bits (number)))
  659.     error_bad_range_arg (2);
  660.       result = (zero_to_bit_string (length));
  661.       (BIT_STRING_LSW (result)) = number;
  662.       return (result);
  663.     }
  664. }
  665.  
  666. SCHEME_OBJECT
  667. DEFUN (bignum_to_bit_string, (length, bignum),
  668.        long length AND SCHEME_OBJECT bignum)
  669. {
  670.   switch (bignum_test (bignum))
  671.     {
  672.     case bignum_comparison_equal:
  673.       return (zero_to_bit_string (length));
  674.     case bignum_comparison_less:
  675.       error_bad_range_arg (2);
  676.     case bignum_comparison_greater:
  677.       if (! (bignum_fits_in_word_p (bignum, length, 0)))
  678.     error_bad_range_arg (2);
  679.       {
  680.     static void btbs_consumer ();
  681.     SCHEME_OBJECT result = (zero_to_bit_string (length));
  682.     unsigned char * result_ptr =
  683.       ((unsigned char *) (BIT_STRING_LOW_PTR (result)));
  684.     bignum_to_digit_stream
  685.       (bignum, (1 << CHAR_BIT), btbs_consumer, (&result_ptr));
  686.     return (result);
  687.       }
  688.     }
  689. }
  690.  
  691. static void
  692. DEFUN (btbs_consumer, (result_ptr, digit),
  693.        unsigned char ** result_ptr
  694.        AND unsigned int digit)
  695. {
  696.   (* (INC_BIT_STRING_PTR (*result_ptr))) = digit;
  697.   return;
  698. }
  699.  
  700. struct bitstr_to_bignm_context
  701. {
  702.   unsigned char *source_ptr;
  703.   unsigned int mask;
  704. };
  705.  
  706. SCHEME_OBJECT
  707. DEFUN (bit_string_to_bignum, (nbits, bitstr),
  708.        long nbits AND SCHEME_OBJECT bitstr)
  709. {
  710.   static unsigned int bstb_producer ();
  711.   struct bitstr_to_bignm_context context;
  712.   int ndigits, skip;
  713.  
  714.   ndigits = ((nbits + (CHAR_BIT - 1)) / CHAR_BIT);
  715.  
  716.   context.mask = (LOW_MASK (((nbits - 1) % (CHAR_BIT)) + 1));
  717.   context.source_ptr =
  718.     ((unsigned char *)
  719.      (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, (nbits - 1))))));
  720.  
  721.   if (ndigits != 0)
  722.   {
  723.     skip = ((sizeof (SCHEME_OBJECT)) -
  724.         (((ndigits - 1) % (sizeof (SCHEME_OBJECT))) + 1));
  725.     while ((--skip) >= 0)
  726.     {
  727.       DEC_BIT_STRING_PTR (context.source_ptr);
  728.     }
  729.   }
  730.  
  731.   return
  732.     (digit_stream_to_bignum (ndigits, bstb_producer,
  733.                  (&context), (1 << CHAR_BIT),
  734.                  0));
  735. }
  736.  
  737. static unsigned int
  738. DEFUN (bstb_producer, (context),
  739.        struct bitstr_to_bignm_context * context)
  740. {
  741.   unsigned int result;
  742.  
  743.   result = (context->mask & (BIT_STRING_WORD (context->source_ptr)));
  744.   context->mask = (LOW_MASK (CHAR_BIT));
  745.   DEC_BIT_STRING_PTR (context->source_ptr);
  746.   return (result);
  747. }
  748.  
  749. /* (UNSIGNED-INTEGER->BIT-STRING length integer)
  750.    INTEGER, which must be a non-negative integer, is converted to
  751.    a bit-string of length LENGTH.  If INTEGER is too large, an
  752.    error is signalled. */
  753.  
  754. DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2, 0)
  755. {
  756.   fast long length;
  757.   fast SCHEME_OBJECT object;
  758.   PRIMITIVE_HEADER (2);
  759.   length = (arg_nonnegative_integer (1));
  760.   object = (ARG_REF (2));
  761.   if (FIXNUM_P (object))
  762.     {
  763.       if (FIXNUM_NEGATIVE_P (object))
  764.     error_bad_range_arg (2);
  765.       PRIMITIVE_RETURN
  766.     (long_to_bit_string
  767.      (length, (UNSIGNED_FIXNUM_TO_LONG (object))));
  768.     }
  769.   if (BIGNUM_P (object))
  770.     PRIMITIVE_RETURN (bignum_to_bit_string (length, object));
  771.   error_wrong_type_arg (2);
  772.   /* NOTREACHED */
  773. }
  774.  
  775. /* (BIT-STRING->UNSIGNED-INTEGER bit-string)
  776.    BIT-STRING is converted to the appropriate non-negative integer.
  777.    This operation is the inverse of `unsigned-integer->bit-string'. */
  778.  
  779. DEFINE_PRIMITIVE ("BIT-STRING->UNSIGNED-INTEGER", Prim_bit_string_to_unsigned, 1, 1, 0)
  780. {
  781.   fast SCHEME_OBJECT bit_string, *scan;
  782.   long nwords, nbits, word;
  783.   PRIMITIVE_HEADER (1);
  784.   CHECK_ARG (1, BIT_STRING_P);
  785.   bit_string = (ARG_REF (1));
  786.   /* Count the number of significant bits.*/
  787.   scan = (BIT_STRING_HIGH_PTR (bit_string));
  788.   nbits = ((BIT_STRING_LENGTH (bit_string)) % OBJECT_LENGTH);
  789.   word =
  790.     ((nbits > 0)
  791.      ? ((* (DEC_BIT_STRING_PTR (scan))) & (LOW_MASK (nbits)))
  792.      : (* (DEC_BIT_STRING_PTR (scan))));
  793.   for (nwords = ((VECTOR_LENGTH (bit_string)) - 1); (nwords > 0); nwords -= 1)
  794.     {
  795.       if (word != 0)
  796.     break;
  797.       word = (* (DEC_BIT_STRING_PTR (scan)));
  798.     }
  799.   if (nwords == 0)
  800.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
  801.   nbits = (((nwords - 1) * OBJECT_LENGTH) + (long_significant_bits (word)));
  802.   PRIMITIVE_RETURN
  803.     ((nbits <= FIXNUM_LENGTH)
  804.      ? (LONG_TO_UNSIGNED_FIXNUM (word))
  805.      : (bit_string_to_bignum (nbits, bit_string)));
  806. }
  807.  
  808. #define READ_BITS_INITIALIZE()                        \
  809.   SCHEME_OBJECT bit_string;                        \
  810.   long end, end_mod, offset;                        \
  811.   SCHEME_OBJECT *start;                            \
  812.   PRIMITIVE_HEADER (3);                            \
  813.   CHECK_ARG (3, BIT_STRING_P);                        \
  814.   bit_string = (ARG_REF (3));                        \
  815.   end = (BIT_STRING_LENGTH (bit_string));                \
  816.   end_mod = (end % OBJECT_LENGTH);                    \
  817.   offset = (arg_nonnegative_integer (2));                \
  818.   start = (READ_BITS_PTR ((ARG_REF (1)), offset, end));            \
  819.   COMPUTE_READ_BITS_OFFSET (offset, end)
  820.  
  821.  
  822. /* (READ-BITS! pointer offset bit-string)
  823.    Read the contents of memory at the address (POINTER,OFFSET)
  824.    into BIT-STRING. */
  825.  
  826. DEFINE_PRIMITIVE ("READ-BITS!", Prim_read_bits_x, 3, 3, 0)
  827. {
  828.   READ_BITS_INITIALIZE ();
  829.   copy_bits (start,
  830.          offset,
  831.          (MEMORY_LOC
  832.           (bit_string,
  833.            (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))))),
  834.          ((end_mod == 0) ? 0 : (OBJECT_LENGTH - end_mod)),
  835.          end);
  836.   PRIMITIVE_RETURN (UNSPECIFIC);
  837. }
  838.  
  839. /* (WRITE-BITS! pointer offset bit-string)
  840.    Write the contents of BIT-STRING in memory at the address
  841.    (POINTER,OFFSET). */
  842.  
  843. DEFINE_PRIMITIVE ("WRITE-BITS!", Prim_write_bits_x, 3, 3, 0)
  844. {
  845.   READ_BITS_INITIALIZE ();
  846.   copy_bits ((MEMORY_LOC
  847.           (bit_string,
  848.            (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))))),
  849.          ((end_mod == 0) ? 0 : (OBJECT_LENGTH - end_mod)),
  850.          start,
  851.          offset,
  852.          end);
  853.   PRIMITIVE_RETURN (UNSPECIFIC);
  854. }
  855.  
  856. /* Search Primitives */
  857.  
  858. #define SUBSTRING_FIND_INITIALIZE()                    \
  859.   SCHEME_OBJECT bit_string;                        \
  860.   long start, end;                            \
  861.   long word, bit, end_word, end_bit, mask;                \
  862.   SCHEME_OBJECT *scan;                            \
  863.   PRIMITIVE_HEADER (3);                            \
  864.   CHECK_ARG (1, BIT_STRING_P);                        \
  865.   bit_string = (ARG_REF (1));                        \
  866.   start = (arg_nonnegative_integer (2));                \
  867.   end = (arg_nonnegative_integer (3));                    \
  868.   if (end > (BIT_STRING_LENGTH (bit_string)))                \
  869.     error_bad_range_arg (3);                        \
  870.   if (start > end)                            \
  871.     error_bad_range_arg (2);                        \
  872.   if (start == end)                            \
  873.     PRIMITIVE_RETURN (SHARP_F)
  874.  
  875. #define SUBSTRING_FIND_NEXT_INITIALIZE()                \
  876.   SUBSTRING_FIND_INITIALIZE ();                        \
  877.   word = (BIT_STRING_INDEX_TO_WORD (bit_string, start));        \
  878.   bit = (start % OBJECT_LENGTH);                    \
  879.   end_word = (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1)));    \
  880.   end_bit = (((end - 1) % OBJECT_LENGTH) + 1);                \
  881.   scan = (MEMORY_LOC (bit_string, word))
  882.  
  883. #define FIND_NEXT_SET_LOOP(init_bit)                    \
  884. {                                    \
  885.   bit = (init_bit);                            \
  886.   mask = (1 << (init_bit));                        \
  887.   while (true)                                \
  888.     {                                    \
  889.       if (((BIT_STRING_WORD (scan)) & mask) != 0)            \
  890.     goto win;                            \
  891.       bit += 1;                                \
  892.       mask <<= 1;                            \
  893.     }                                    \
  894. }
  895.  
  896. DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_bit, 3, 3, 0)
  897. {
  898.   SUBSTRING_FIND_NEXT_INITIALIZE ();
  899.   if (word == end_word)
  900.     {
  901.       if ((((end_bit - bit) == OBJECT_LENGTH) &&
  902.        ((BIT_STRING_WORD (scan)) != 0)) ||
  903.       (((BIT_STRING_WORD (scan)) & (ANY_MASK ((end_bit - bit), bit)))
  904.        != 0))
  905.     {
  906.       FIND_NEXT_SET_LOOP (bit);
  907.     }
  908.       PRIMITIVE_RETURN (SHARP_F);
  909.     }
  910.   else if (((BIT_STRING_WORD (scan)) &
  911.         ((bit == 0) ? (~ 0) : (ANY_MASK ((OBJECT_LENGTH - bit), bit))))
  912.        != 0)
  913.     {
  914.       FIND_NEXT_SET_LOOP (bit);
  915.     }
  916.   INC_BIT_STRING_PTR (word);
  917.   while (word != end_word)
  918.   {
  919.     if ((* (INC_BIT_STRING_PTR (scan))) != 0)
  920.       {
  921.     FIND_NEXT_SET_LOOP (0);
  922.       }
  923.     INC_BIT_STRING_PTR (word);
  924.   }
  925.   if (((* (INC_BIT_STRING_PTR (scan))) &
  926.        ((end_bit == OBJECT_LENGTH) ? (~ 0) : (LOW_MASK (end_bit))))
  927.       != 0)
  928.     {
  929.       FIND_NEXT_SET_LOOP (0);
  930.     }
  931.   PRIMITIVE_RETURN (SHARP_F);
  932.  win:
  933.   PRIMITIVE_RETURN
  934.     (LONG_TO_UNSIGNED_FIXNUM
  935.      (BIT_STRING_INDEX_PAIR_TO_INDEX (bit_string, word, bit)));
  936. }
  937.